home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / enriched.el.z / enriched.el
Encoding:
Text File  |  1998-10-28  |  16.7 KB  |  476 lines
  1. ;;; enriched.el --- read and save files in text/enriched format
  2.  
  3. ;; Copyright (c) 1994, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu>
  6. ;; Keywords: wp, faces
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; This file implements reading, editing, and saving files with
  28. ;; text-properties such as faces, levels of indentation, and true line
  29. ;; breaks distinguished from newlines just used to fit text into the window.
  30.  
  31. ;; The file format used is the MIME text/enriched format, which is a
  32. ;; standard format defined in internet RFC 1563.  All standard annotations
  33. ;; are supported except for <smaller> and <bigger>, which are currently not
  34. ;; possible to display.
  35.  
  36. ;; A separate file, enriched.doc, contains further documentation and other
  37. ;; important information about this code.  It also serves as an example
  38. ;; file in text/enriched format.  It should be in the etc directory of your
  39. ;; emacs distribution.
  40.  
  41. ;;; Code:
  42.  
  43. (provide 'enriched)
  44. (if window-system (require 'facemenu))
  45.  
  46. ;;;
  47. ;;; Variables controlling the display
  48. ;;;
  49.  
  50. (defvar enriched-verbose t
  51.   "*If non-nil, give status messages when reading and writing files.")
  52.  
  53. (defvar enriched-default-right-margin 10
  54.   "*Default amount of space to leave on the right edge of the screen.
  55. This can be increased inside text by changing the 'right-margin text property.
  56. Measured in character widths.  If the screen is narrower than this, it is
  57. assumed to be 0.")
  58.  
  59. (defvar enriched-fill-after-visiting t
  60.   "If t, fills paragraphs when reading in enriched documents.
  61. If nil, only fills when you explicitly request it.  If the value is 'ask, then
  62. it will query you whether to fill.
  63. Filling is never done if the current text-width is the same as the value
  64. stored in the file.")
  65.  
  66. ;;;
  67. ;;; Set up faces & display table
  68. ;;;
  69.  
  70. ;; A slight cheat - all emacs's faces are fixed-width.  
  71. ;; The idea is just to pick one that looks different from the default.
  72. (if (internal-find-face 'fixed)
  73.     nil
  74.   (make-face 'fixed)
  75.   (if window-system
  76.       (set-face-font 'fixed
  77.              (car (or (x-list-fonts "*fixed-medium*" 
  78.                         'default (selected-frame))
  79.                   (x-list-fonts "*fixed*" 
  80.                         'default (selected-frame)))))))
  81.                   
  82. (if (internal-find-face 'excerpt)
  83.     nil
  84.   (make-face 'excerpt)
  85.   (if window-system
  86.       (make-face-italic 'excerpt nil t)))
  87.  
  88. (defconst enriched-display-table (or (copy-sequence standard-display-table)
  89.                      (make-display-table)))
  90. (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
  91.  
  92. (defconst enriched-par-props '(left-margin right-margin justification)
  93.   "Text-properties that usually apply to whole paragraphs.
  94. These are set front-sticky everywhere except at hard newlines.")
  95.  
  96. ;;;
  97. ;;; Variables controlling the file format
  98. ;;;   (bidirectional)
  99.  
  100. (defconst enriched-initial-annotation
  101.   (lambda ()
  102.     (format "Content-Type: text/enriched\nText-Width: %d\n\n"
  103.         (enriched-text-width)))
  104.   "What to insert at the start of a text/enriched file.
  105. If this is a string, it is inserted.  If it is a list, it should be a lambda
  106. expression, which is evaluated to get the string to insert.")
  107.  
  108. (defconst enriched-annotation-format "<%s%s>"
  109.   "General format of enriched-text annotations.")
  110.  
  111. (defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
  112.   "Regular expression matching enriched-text annotations.")
  113.  
  114. (defconst enriched-translations
  115.   '((face          (bold-italic "bold" "italic")
  116.            (bold        "bold")
  117.            (italic      "italic")
  118.            (underline   "underline")
  119.            (fixed       "fixed")
  120.            (excerpt     "excerpt")
  121.            (default     )
  122.            (nil         enriched-encode-other-face))
  123.     (left-margin   (4           "indent"))
  124.     (right-margin  (4           "indentright"))
  125.     (justification (none        "nofill")
  126.            (right       "flushright")
  127.            (left        "flushleft")
  128.            (full        "flushboth")
  129.            (center      "center")) 
  130.     (PARAMETER     (t           "param")) ; Argument of preceding annotation
  131.     ;; The following are not part of the standard:
  132.     (FUNCTION      (enriched-decode-foreground "x-color")
  133.            (enriched-decode-background "x-bg-color"))
  134.     (read-only     (t           "x-read-only"))
  135.     (unknown       (nil         format-annotate-value))
  136. ;   (font-size     (2           "bigger")       ; unimplemented
  137. ;           (-2          "smaller"))
  138. )
  139.   "List of definitions of text/enriched annotations.
  140. See `format-annotate-region' and `format-deannotate-region' for the definition
  141. of this structure.")
  142.  
  143. (defconst enriched-ignore
  144.   '(front-sticky rear-nonsticky hard)
  145.   "Properties that are OK to ignore when saving text/enriched files.
  146. Any property that is neither on this list nor dealt with by
  147. `enriched-translations' will generate a warning.")
  148.  
  149. ;;; Internal variables
  150.  
  151. (defvar enriched-mode nil
  152.   "True if Enriched mode is in use.")
  153. (make-variable-buffer-local 'enriched-mode)
  154.  
  155. (if (not (assq 'enriched-mode minor-mode-alist))
  156.     (setq minor-mode-alist
  157.       (cons '(enriched-mode " Enriched")
  158.         minor-mode-alist)))
  159.  
  160. (defvar enriched-mode-hook nil
  161.   "Functions to run when entering Enriched mode.
  162. If you set variables in this hook, you should arrange for them to be restored
  163. to their old values if you leave Enriched mode.  One way to do this is to add
  164. them and their old values to `enriched-old-bindings'.")
  165.  
  166. (defvar enriched-old-bindings nil
  167.   "Store old variable values that we change when entering mode.
  168. The value is a list of \(VAR VALUE VAR VALUE...).")
  169. (make-variable-buffer-local 'enriched-old-bindings)
  170.  
  171. (defvar enriched-text-width nil)
  172. (make-variable-buffer-local 'enriched-text-width)
  173.  
  174. ;;;
  175. ;;; Define the mode
  176. ;;;
  177.  
  178. ;;;###autoload
  179. (defun enriched-mode (&optional arg)
  180.   "Minor mode for editing text/enriched files.
  181. These are files with embedded formatting information in the MIME standard
  182. text/enriched format.
  183. Turning the mode on runs `enriched-mode-hook'.
  184.  
  185. More information about Enriched mode is available in the file 
  186. etc/enriched.doc  in the Emacs distribution directory.
  187.  
  188. Commands:
  189.  
  190. \\<enriched-mode-map>\\{enriched-mode-map}"
  191.   (interactive "P")
  192.   (let ((mod (buffer-modified-p)))
  193.     (cond ((or (<= (prefix-numeric-value arg) 0)
  194.            (and enriched-mode (null arg)))
  195.        ;; Turn mode off
  196.        (setq enriched-mode nil)
  197.        (setq buffer-file-format (delq 'text/enriched buffer-file-format))
  198.        ;; restore old variable values
  199.        (while enriched-old-bindings
  200.          (funcall 'set (car enriched-old-bindings)
  201.               (car (cdr enriched-old-bindings)))
  202.          (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
  203.  
  204.       (enriched-mode nil)        ; Mode already on; do nothing.
  205.  
  206.       (t (setq enriched-mode t)    ; Turn mode on
  207.          (if (not (memq 'text/enriched buffer-file-format))
  208.          (setq buffer-file-format 
  209.                (cons 'text/enriched buffer-file-format)))
  210.          ;; Save old variable values before we change them.
  211.          ;; These will be restored if we exit Enriched mode.
  212.          (setq enriched-old-bindings
  213.            (list 'buffer-display-table buffer-display-table
  214.              'indent-line-function indent-line-function
  215.              'use-hard-newlines    use-hard-newlines
  216.              'default-text-properties default-text-properties))
  217.          (make-local-variable 'indent-line-function)
  218.          (make-local-variable 'use-hard-newlines)
  219.          (make-local-variable 'default-text-properties)
  220.          (setq indent-line-function 'indent-to-left-margin
  221.            buffer-display-table  enriched-display-table
  222.            use-hard-newlines     t)
  223.          (let ((sticky (plist-get default-text-properties 'front-sticky))
  224.            (p enriched-par-props))
  225.            (while p
  226.          (if (not (memq (car p) sticky))
  227.              (setq sticky (cons (car p) sticky)))
  228.          (setq p (cdr p)))
  229.            (if sticky
  230.            (setq default-text-properties
  231.              (plist-put default-text-properties
  232.                     'front-sticky sticky))))
  233.          (run-hooks 'enriched-mode-hook)))
  234.     (set-buffer-modified-p mod)
  235.     (force-mode-line-update)))
  236.  
  237. ;;;
  238. ;;; Keybindings
  239. ;;;
  240.  
  241. (defvar enriched-mode-map nil
  242.   "Keymap for Enriched mode.")
  243.  
  244. (if (null enriched-mode-map)
  245.     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
  246.  
  247. (if (not (assq 'enriched-mode minor-mode-map-alist))
  248.     (setq minor-mode-map-alist
  249.       (cons (cons 'enriched-mode enriched-mode-map)
  250.         minor-mode-map-alist)))
  251.  
  252. (define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
  253. (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
  254. (define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
  255. (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
  256. (define-key enriched-mode-map "\M-S" 'set-justification-center)
  257. (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
  258. (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
  259. (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
  260.  
  261. ;;;
  262. ;;; Some functions dealing with text-properties, especially indentation
  263. ;;;
  264.  
  265. (defun enriched-map-property-regions (prop func &optional from to)
  266.   "Apply a function to regions of the buffer based on a text property.
  267. For each contiguous region of the buffer for which the value of PROPERTY is
  268. eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
  269. region over which to scan.
  270.  
  271. The specified function receives three arguments: the VALUE of the property in
  272. the region, and the START and END of each region."
  273.   (save-excursion
  274.     (save-restriction
  275.       (if to (narrow-to-region (point-min) to))
  276.       (goto-char (or from (point-min)))
  277.       (let ((begin (point))
  278.         end
  279.         (marker (make-marker))
  280.         (val (get-text-property (point) prop)))
  281.     (while (setq end (text-property-not-all begin (point-max) prop val))
  282.       (move-marker marker end)
  283.       (funcall func val begin (marker-position marker))
  284.       (setq begin (marker-position marker)
  285.         val (get-text-property marker prop)))
  286.     (if (< begin (point-max))
  287.         (funcall func val begin (point-max)))))))
  288.  
  289. (put 'enriched-map-property-regions 'lisp-indent-hook 1)
  290.  
  291. (defun enriched-insert-indentation (&optional from to)
  292.   "Indent and justify each line in the region."
  293.   (save-excursion
  294.     (save-restriction
  295.       (if to (narrow-to-region (point-min) to))
  296.       (goto-char (or from (point-min)))
  297.       (if (not (bolp)) (forward-line 1))
  298.       (while (not (eobp))
  299.     (if (eolp)
  300.         nil ; skip blank lines
  301.       (indent-to (current-left-margin))
  302.       (justify-current-line t nil t))
  303.     (forward-line 1)))))
  304.  
  305. (defun enriched-text-width ()
  306.   "The width of unindented text in this window, in characters.
  307. This is the width of the window minus `enriched-default-right-margin'."
  308.   (or enriched-text-width
  309.       (let ((ww (window-width)))
  310.     (setq enriched-text-width
  311.           (if (> ww enriched-default-right-margin)
  312.           (- ww enriched-default-right-margin)
  313.         ww)))))
  314.  
  315. ;;;
  316. ;;; Encoding Files
  317. ;;;
  318.  
  319. ;;;###autoload
  320. (defun enriched-encode (from to)
  321.   (if enriched-verbose (message "Enriched: encoding document..."))
  322.   (save-restriction
  323.     (narrow-to-region from to)
  324.     (delete-to-left-margin)
  325.     (unjustify-region)
  326.     (goto-char from)
  327.     (format-replace-strings '(("<" . "<<")))
  328.     (format-insert-annotations 
  329.      (format-annotate-region from (point-max) enriched-translations
  330.                  'enriched-make-annotation enriched-ignore))
  331.     (goto-char from)
  332.     (insert (if (stringp enriched-initial-annotation)
  333.         enriched-initial-annotation
  334.           (funcall enriched-initial-annotation)))
  335.     (enriched-map-property-regions 'hard
  336.       (lambda (v b e)
  337.     (if (and v (= ?\n (char-after b)))
  338.         (progn (goto-char b) (insert "\n"))))
  339.       (point) nil)
  340.     (if enriched-verbose (message nil))
  341.     ;; Return new end.
  342.     (point-max)))
  343.  
  344. (defun enriched-make-annotation (name positive)
  345.   "Format an annotation called NAME.
  346. If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
  347. matching close."
  348.   (cond ((stringp name)
  349.      (format enriched-annotation-format (if positive "" "/") name))
  350.     ;; Otherwise it is an annotation with parameters, represented as a list
  351.     (positive
  352.      (let ((item (car name))
  353.            (params (cdr name)))
  354.        (concat (format enriched-annotation-format "" item)
  355.            (mapconcat (lambda (i) (concat "<param>" i "</param>"))
  356.                   params ""))))
  357.     (t (format enriched-annotation-format "/" (car name)))))
  358.  
  359. (defun enriched-encode-other-face (old new)
  360.   "Generate annotations for random face change.
  361. One annotation each for foreground color, background color, italic, etc."
  362.   (cons (and old (enriched-face-ans old))
  363.     (and new (enriched-face-ans new))))
  364.         
  365. (defun enriched-face-ans (face)
  366.   "Return annotations specifying FACE."
  367.   (cond ((string-match "^fg:" (symbol-name face))
  368.      (list (list "x-color" (substring (symbol-name face) 3))))
  369.     ((string-match "^bg:" (symbol-name face))
  370.      (list (list "x-bg-color" (substring (symbol-name face) 3))))
  371.     ((let* ((fg (face-foreground face))
  372.         (bg (face-background face))
  373.         (props (face-font face t))
  374.         (ans (cdr (format-annotate-single-property-change
  375.                'face nil props enriched-translations))))
  376.        (if fg (setq ans (cons (list "x-color" fg) ans)))
  377.        (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
  378.        ans))))
  379.  
  380. ;;;
  381. ;;; Decoding files
  382. ;;;
  383.  
  384. ;;;###autoload
  385. (defun enriched-decode (from to)
  386.   (if enriched-verbose (message "Enriched: decoding document..."))
  387.   (save-excursion
  388.     (save-restriction
  389.       (narrow-to-region from to)
  390.       (goto-char from)
  391.       (let ((file-width (enriched-get-file-width))
  392.         (use-hard-newlines t))
  393.     (enriched-remove-header)
  394.  
  395.     ;; Deal with newlines
  396.     (goto-char from)
  397.     (while (search-forward-regexp "\n\n+" nil t)
  398.       (if (current-justification)
  399.           (delete-char -1))
  400.       (put-text-property (match-beginning 0) (point) 'hard t)
  401.       (put-text-property (match-beginning 0) (point) 'front-sticky nil))
  402.  
  403.     ;; Translate annotations
  404.     (format-deannotate-region from (point-max) enriched-translations
  405.                   'enriched-next-annotation)
  406.  
  407.     ;; Fill paragraphs
  408.     (if (or (and file-width        ; possible reasons not to fill:
  409.              (= file-width (enriched-text-width))) ; correct wd.
  410.         (null enriched-fill-after-visiting) ; never fill
  411.         (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
  412.              (not (y-or-n-p "Re-fill for current display width? "))))
  413.         ;; Minimally, we have to insert indentation and justification.
  414.         (enriched-insert-indentation)
  415.       (if enriched-verbose (message "Filling paragraphs..."))
  416.       (fill-region (point-min) (point-max))))
  417.       (if enriched-verbose (message nil))
  418.       (point-max))))
  419.  
  420. (defun enriched-next-annotation ()
  421.   "Find and return next text/enriched annotation.
  422. Any \"<<\" strings encountered are converted to \"<\".
  423. Return value is \(begin end name positive-p), or nil if none was found."
  424.   (while (and (search-forward "<" nil 1)
  425.           (progn (goto-char (match-beginning 0))
  426.              (not (looking-at enriched-annotation-regexp))))
  427.     (forward-char 1)
  428.     (if (= ?< (char-after (point)))
  429.     (delete-char 1)
  430.       ;; A single < that does not start an annotation is an error,
  431.       ;; which we note and then ignore.
  432.       (message "Warning: malformed annotation in file at %s" 
  433.            (1- (point)))))
  434.   (if (not (eobp))
  435.       (let* ((beg (match-beginning 0))
  436.          (end (match-end 0))
  437.          (name (downcase (buffer-substring 
  438.                   (match-beginning 2) (match-end 2))))
  439.          (pos (not (match-beginning 1))))
  440.     (list beg end name pos))))
  441.  
  442. (defun enriched-get-file-width ()
  443.   "Look for file width information on this line."
  444.   (save-excursion
  445.     (if (search-forward "Text-Width: " (+ (point) 1000) t)
  446.     (read (current-buffer)))))
  447.  
  448. (defun enriched-remove-header ()
  449.   "Remove file-format header at point."
  450.   (while (looking-at "^[-A-Za-z]+: .*\n")
  451.     (delete-region (point) (match-end 0)))
  452.   (if (looking-at "^\n")
  453.       (delete-char 1)))
  454.  
  455. (defun enriched-decode-foreground (from to color)
  456.   (let ((face (intern (concat "fg:" color))))
  457.     (cond ((internal-find-face face))
  458.       ((and window-system (facemenu-get-face face)))
  459.       (window-system
  460.        (message "Warning: color \"%s\" is not defined." color))
  461.       ((make-face face)
  462.        (message "Warning: Color \"%s\" can't be displayed." color)))
  463.     (list from to 'face face)))
  464.  
  465. (defun enriched-decode-background (from to color)
  466.   (let ((face (intern (concat "bg:" color))))
  467.     (cond ((internal-find-face face))
  468.       ((and window-system (facemenu-get-face face)))
  469.       (window-system
  470.        (message "Warning: color \"%s\" is not defined." color))
  471.       ((make-face face)
  472.        (message "Warning: Color \"%s\" can't be displayed." color)))
  473.     (list from to 'face face)))
  474.  
  475. ;;; enriched.el ends here
  476.